unit uFrmPrintData;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, Printers, StdCtrls;

type
  TFrmPrintData = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    procedure PrintForm;
  end;

var
  FrmPrintData: TFrmPrintData;

implementation

{$R *.dfm}

procedure TFrmPrintData.Button1Click(Sender: TObject);
begin
//  PrintForm();
  print();
end;

procedure TFrmPrintData.PrintForm;
var
  DC: HDC;
  isDcPalDevice: Bool;
  MemDC: HDC;
  MemBitmap: HBITMAP;
  OldMemBitmap: HBITMAP;
  hDibHeader: THandle;
  pDibHeader: Pointer;
  hBits: THandle;
  pBits: Pointer;
  ScaleX: Double;
  ScaleY: Double;
  pPal: PLOGPALETTE;
  pal: HPALETTE;
  OldPal: HPALETTE;
  i: Integer;
begin
  { Get the screen dc }
  DC := GetDC(0);
  { Create a compatible dc }
  MemDC := CreateCompatibleDC(DC);
  { create a bitmap }
  MemBitmap := CreateCompatibleBitmap(DC, Self.Width, Self.Height);
  { select the bitmap into the dc }
  OldMemBitmap := SelectObject(MemDC, MemBitmap);

  { Lets prepare to try a fixup for broken video drivers }
  isDcPalDevice := False;
  if GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    GetMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    FillChar(pPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := GetSystemPaletteEntries(DC, 0, 256, pPal^.palPalEntry);
    if pPal^.palNumEntries <> 0 then
    begin
      pal := CreatePalette(pPal^);
      OldPal := SelectPalette(MemDC, pal, False);
      isDcPalDevice := True
    end
    else
      FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
  end;
  { copy from the screen to the memdc/bitmap }
  BitBlt(MemDC, 0, 0, Self.Width, Self.Height, DC, Self.Left, Self.Top, SRCCOPY);

  if isDcPalDevice = True then
  begin
    SelectPalette(MemDC, OldPal, False);
    DeleteObject(pal);
  end;
  { unselect the bitmap }
  SelectObject(MemDC, OldMemBitmap);
  { delete the memory dc }
  DeleteDC(MemDC);
  { Allocate memory for a DIB structure }
  hDibHeader := GlobalAlloc(GHND, SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) * 256));
  { get a pointer to the alloced memory }
  pDibHeader := GlobalLock(hDibHeader);

  { fill in the dib structure with info on the way we want the DIB }
  FillChar(pDibHeader^, SizeOf(TBITMAPINFO) + (SizeOf(TRGBQUAD) * 256), #0);
  PBITMAPINFOHEADER(pDibHeader)^.biSize := SizeOf(TBITMAPINFOHEADER);
  PBITMAPINFOHEADER(pDibHeader)^.biPlanes := 1;
  PBITMAPINFOHEADER(pDibHeader)^.biBitCount := 8;
  PBITMAPINFOHEADER(pDibHeader)^.biWidth := Self.Width;
  PBITMAPINFOHEADER(pDibHeader)^.biHeight := Self.Height;
  PBITMAPINFOHEADER(pDibHeader)^.biCompression := BI_RGB;

  { find out how much memory for the bits }
  GetDIBits(DC, MemBitmap, 0, Self.Height, nil, TBITMAPINFO(pDibHeader^), DIB_RGB_COLORS);

  { Alloc memory for the bits }
  hBits := GlobalAlloc(GHND, PBITMAPINFOHEADER(pDibHeader)^.BiSizeImage);

  { Get a pointer to the bits }
  pBits := GlobalLock(hBits);

  { Call fn again, but this time give us the bits! }
  GetDIBits(DC, MemBitmap, 0, Self.Height, pBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS);

  { Lets try a fixup for broken video drivers }
  if isDcPalDevice = True then
  begin
    for i := 0 to (pPal^.palNumEntries - 1) do
    begin
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed := pPal^.palPalEntry[i].peRed;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen := pPal^.palPalEntry[i].peGreen;
      PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue := pPal^.palPalEntry[i].peBlue;
    end;
    FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
  end;
  { Release the screen dc }
  ReleaseDC(0, DC);
  { Delete the bitmap }
  DeleteObject(MemBitmap);

  { Start print job }
  Printer.BeginDoc;

  { Scale print size }
  ScaleX := Self.Width * 3;
  ScaleY := Self.Height * 3;

  {
    if Printer.PageWidth < Printer.PageHeight then
    begin
    ScaleX := Printer.PageWidth;
    ScaleY := Self.Height*(Printer.PageWidth/Self.Width);
    end
    else
    begin
    ScaleX := Self.Width*(Printer.PageHeight/Self.Height);
    ScaleY := Printer.PageHeight;
    end;
    }

  { Just incase the printer drver is a palette device }
  isDcPalDevice := False;
  if GetDeviceCaps(Printer.Canvas.Handle, RASTERCAPS) and RC_PALETTE = RC_PALETTE then
  begin
    { Create palette from dib }
    GetMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    FillChar(pPal^, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)), #0);
    pPal^.palVersion := $300;
    pPal^.palNumEntries := 256;
    for i := 0 to (pPal^.palNumEntries - 1) do
    begin
      pPal^.palPalEntry[i].peRed := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbRed;
      pPal^.palPalEntry[i].peGreen := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbGreen;
      pPal^.palPalEntry[i].peBlue := PBitmapInfo(pDibHeader)^.bmiColors[i].rgbBlue;
    end;
    pal := CreatePalette(pPal^);
    FreeMem(pPal, SizeOf(TLOGPALETTE) + (255 * SizeOf(TPALETTEENTRY)));
    OldPal := SelectPalette(Printer.Canvas.Handle, pal, False);
    isDcPalDevice := True
  end;
  { send the bits to the printer }
  StretchDiBits(Printer.Canvas.Handle, 0, 0, Round(ScaleX), Round(ScaleY), 0, 0, Self.Width, Self.Height, pBits, PBitmapInfo(pDibHeader)^, DIB_RGB_COLORS, SRCCOPY);

  { Just incase you printer drver is a palette device }
  if isDcPalDevice = True then
  begin
    SelectPalette(Printer.Canvas.Handle, OldPal, False);
    DeleteObject(pal);
  end;
  { Clean up allocated memory }
  GlobalUnlock(hBits);
  GlobalFree(hBits);
  GlobalUnlock(hDibHeader);
  GlobalFree(hDibHeader);

  { end the print job }
  Printer.EndDoc;
end;

end.
